home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / arc.tcl < prev    next >
Encoding:
Text File  |  1995-06-08  |  3.9 KB  |  141 lines
  1. # This file creates a visual test for arcs.  It is part of the Tk
  2. # visual test suite, which is invoked via the "visual" script.
  3. #
  4. # @(#) arc.tcl 1.4 95/06/07 21:54:30
  5.  
  6. catch {destroy .t}
  7. toplevel .t
  8. wm title .t "Visual Tests for Canvas Arcs"
  9. wm iconname .t "Arcs"
  10. wm geom .t +0+0
  11. wm minsize .t 1 1
  12.  
  13. canvas .t.c -width 650 -height 600 -relief raised
  14. pack .t.c -expand yes -fill both
  15. button .t.quit -text Quit -command {destroy .t}
  16. pack .t.quit -side bottom -pady 3 -ipadx 4 -ipady 2
  17.  
  18. puts "depth is [winfo depth .t]"
  19. if {[winfo depth .t] > 1} {
  20.     set fill1 aquamarine3
  21.     set fill2 aquamarine3
  22.     set fill3 IndianRed1
  23.     set outline2 IndianRed3
  24. } else {
  25.     set fill1 black
  26.     set fill2 white
  27.     set fill3 Black
  28.     set outline2 white
  29. }
  30. set outline black
  31.  
  32. .t.c create arc 20 20 220 120 -start 30 -extent 270 -outline $fill1 -width 14 \
  33.     -style arc
  34. .t.c create arc 260 20 460 120 -start 30 -extent 270 -fill $fill2 -width 14 \
  35.     -style chord -outline $outline
  36. .t.c create arc 500 20 620 160 -start 30 -extent 270 -fill {} -width 14 \
  37.     -style chord -outline $outline -outlinestipple gray50
  38. .t.c create arc 20 260 140 460 -start 45 -extent 90 -fill $fill2 -width 14 \
  39.     -style pieslice -outline $outline
  40. .t.c create arc 180 260 300 460 -start 45 -extent 90 -fill {} -width 14 \
  41.     -style pieslice -outline $outline
  42. .t.c create arc 340 260 460 460 -start 30 -extent 150 -fill $fill2 -width 14 \
  43.     -style chord -outline $outline -stipple gray50 -outlinestipple gray25
  44. .t.c create arc 500 260 620 460 -start 30 -extent 150 -fill {} -width 14 \
  45.     -style chord -outline $outline
  46. .t.c create arc 20 450 140 570 -start 135 -extent 270 -fill $fill1 -width 14 \
  47.     -style pieslice -outline {}
  48. .t.c create arc 180 450 300 570 -start 30 -extent -90 -fill $fill1 -width 14 \
  49.     -style pieslice -outline {}
  50. .t.c create arc 340 450 460 570 -start 320 -extent 270 -fill $fill1 -width 14 \
  51.     -style chord -outline {}
  52. .t.c create arc 500 450 620 570 -start 350 -extent -110 -fill $fill1 -width 14 \
  53.     -style chord -outline {}
  54. .t.c addtag arc withtag all
  55. .t.c addtag circle withtag [.t.c create oval 320 200 340 220 -fill MistyRose3]
  56.  
  57. .t.c bind arc <Any-Enter> {
  58.     set prevFill [lindex [.t.c itemconf current -fill] 4]
  59.     set prevOutline [lindex [.t.c itemconf current -outline] 4]
  60.     if {($prevFill != "") || ($prevOutline == "")} {
  61.     .t.c itemconf current -fill $fill3
  62.     }
  63.     if {$prevOutline != ""} {
  64.     .t.c itemconf current -outline $outline2
  65.     }
  66. }
  67. .t.c bind arc <Any-Leave> {.t.c itemconf current -fill $prevFill -outline $prevOutline}
  68.  
  69. bind .t.c <1> {markarea %x %y}
  70. bind .t.c <B1-Motion> {strokearea %x %y}
  71.  
  72. proc markarea {x y} {
  73.     global areaX1 areaY1
  74.     set areaX1 $x
  75.     set areaY1 $y
  76. }
  77.  
  78. proc strokearea {x y} {
  79.     global areaX1 areaY1 areaX2 areaY2
  80.     if {($areaX1 != $x) && ($areaY1 != $y)} {
  81.     .t.c delete area
  82.     .t.c addtag area withtag [.t.c create rect $areaX1 $areaY1 $x $y \
  83.         -outline black]
  84.     set areaX2 $x
  85.     set areaY2 $y
  86.     }
  87. }
  88.  
  89. bind .t.c <Control-f> {
  90.     puts stdout "Enclosed: [.t.c find enclosed $areaX1 $areaY1 $areaX2 $areaY2]"
  91.     puts stdout "Overlapping: [.t.c find overl $areaX1 $areaY1 $areaX2 $areaY2]"
  92. }
  93.  
  94. bind .t.c <3> {puts stdout "%x %y"}
  95.  
  96. # The code below allows the circle to be move by shift-dragging.
  97.  
  98. bind .t.c <Shift-1> {
  99.     set curx %x
  100.     set cury %y
  101. }
  102.  
  103. bind .t.c <Shift-B1-Motion> {
  104.     .t.c move circle [expr %x-$curx] [expr %y-$cury]
  105.     set curx %x
  106.     set cury %y
  107. }
  108.  
  109. # The binding below flashes the closest item to the mouse.
  110.  
  111. bind .t.c <Control-c> {
  112.     set closest [.t.c find closest %x %y]
  113.     set oldfill [lindex [.t.c itemconf $closest -fill] 4]
  114.     .t.c itemconf $closest -fill IndianRed1
  115.     after 200 [list .t.c itemconfig $closest -fill $oldfill]
  116. }
  117.  
  118. proc c {option value} {.t.c itemconf 2 $option $value}
  119.  
  120. bind .t.c a {
  121.     set go 1
  122.     set i 1
  123.     while {$go} {
  124.     if {$i >= 50} {
  125.         set delta -5
  126.     }
  127.     if {$i <= 5} {
  128.         set delta 5
  129.     }
  130.     incr i $delta
  131.     c -start $i
  132.     c -extent [expr 360-2*$i]
  133.     after 20
  134.     update
  135.     }
  136. }
  137.  
  138. bind .t.c b {set go 0}
  139.  
  140. bind .t.c <Control-x> {.t.c delete current}
  141.